home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Pocket Forth 0.6.3 / Source / Dictionary.txt < prev    next >
Encoding:
Text File  |  1993-06-28  |  44.5 KB  |  1,197 lines  |  [TEXT/McSk]
  1. ; this file is: Dictionary.txt  --  forth words
  2. ; Tue Apr 05, 1988 21:59:10 load files >32K
  3. ; Thu Apr 07, 1988 15:59:46 nested loads
  4. ; Tue Apr 19, 1988 05:05:37 change "?BUTTON"
  5. ; Mon Apr 25, 1988 15:10:19 implement macros
  6. ; Tue Apr 26, 1988 19:49:49 optomizing "BACK"
  7. ; Thu Apr 28, 1988 23:09:23 fix ID.  better CONSTANT,2CONSTANT  add zero
  8. ; Fri Apr 29, 1988 09:43:49 add DLITERAL
  9. ; Sun May 01, 1988 04:24:52 make VARIABLE a macro
  10. ; Thu May 12, 1988 11:41:08 remove (PDO)  add 1- 2- & SP@  use slashFail
  11. ; Sun May 29, 1988 20:16:39 make CREATE shorter
  12. ; Tue May 31, 1988 14:27:25 make +MD a 4 byte macro  remove 2-
  13. ; Tue Jun 07, 1988 11:39:00 add R0@, S0@, RP@  redo STOD
  14. ; Sun Jun 23, 1991 09:33:00 add OPEN
  15. ; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr)
  16. ; Sun Feb 02, 1992 00:02:00 fix BACK
  17. ; Wed Apr 01, 1992 00:12:00 change STKCHK
  18. ; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front
  19. ; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add AE: ;AE> ?GESTALT
  20. ; Sat Sep 19, 1992 17:05:00 fix FROLL in decimal places 15-19
  21. ; Fri Jan 22, 1993 19:28:00 fix TYPE
  22. ; Mon Apr 19, 1993 22:58:00 move ?BUTTON and FLITERAL
  23. ; Thu May 06, 1993 23:04:00 fix +LOOP and QUIT
  24. ; Sat May 29, 1993 15:20:00 fix TYPE (again)
  25. ; Tue Jun 01, 1993 23:25:00 add WARM, DEPTH
  26. ; Wed Jun 09, 1993 20:17:00 change IMMEDIATE,PAGE,doLoad,header,dictstart
  27.  
  28. DictStart:
  29.     DC.L    0            ; End of dictionary search
  30.     
  31.     DC.B    128+1,13,0,0        ; "{cr}" ( -- ) goto restart
  32.     DC.W    dictstart-base
  33. CRet:    MOVE.L    rzero-base(bp),rs    ; reset return stack
  34.     JMP    Restart-base(BP)    ; and jump
  35.     
  36.     DC.B    128+1,0,0,0        ; "{null}" ( -- ) same as cret
  37.     DC.W    cret-theLink
  38. NRet:    BRA.S    cret
  39.  
  40.     DC.B    128+1,'\',0,0        ; "\" ( -- ) backslash
  41.     DC.W    nret-theLink        ;  line ending comment
  42. Backsl:    bra.s    cret
  43.  
  44.     DC.B    9,'?TE'            ; "?terminal" ( -- flag )
  45.     DC.W    backsl -theLink        ;  was a key pressed?
  46. QTerm:    JSR    NextEvent-base(BP)
  47.     CLR    -(PS)
  48.     TST    kflag-base(BP)
  49.     BEQ.S    @0
  50.     SUBQ    #1,(PS)
  51.     @0:    RTS
  52.  
  53.     DC.B    3,'KEY'            ; "key" ( -- ascii )
  54.     DC.W    qterm-theLink        ;   wait for a key press
  55. Key:    BSR.S    Curs
  56.     @0:    JSR    NextEvent-base(BP)    ; set kflag if a key is pressed
  57.     TST    KFlag-base(BP)        ; ( among other things... )
  58.     BEQ.S    @0
  59.     BSR.S    NoCurs
  60.     MOVE    KFlag-base(BP),-(PS)
  61.     RTS
  62.  
  63. NoCurs:    MOVE    #10,-(SP)        ; SrcXor mode
  64.     _PenMode
  65.   Curs:    clr.l    -(sp)
  66.     addq.l    #6,(sp)
  67.     _Move
  68.     MOVE.L    #$0000FFFA,-(SP)    ; draw 6 pixels to the left
  69.     _Line
  70.     _PenNormal
  71.     RTS
  72.  
  73.     DC.B    6,'?ST'            ; "?stack" ( ? -- )
  74.     DC.W    key-theLink
  75. StkChk: CMPA.L    Szero-base(BP),PS
  76.     BGT.S    @0
  77.     RTS
  78.     @0:    JSR    space-base(BP)
  79.       MOVEQ    #42,D0            ; print *  if stack underflow
  80.     JSR    EmitCode-base(BP)
  81.     BRA.S    huh
  82.  
  83.     DC.B    7,'?BU'            ; "?button" ( -- flag )
  84.     DC.W    StkChk-theLink
  85. QButton:
  86.     CLR    -(SP)
  87.     _Button
  88.     MOVE    (SP)+,-(PS)
  89.     BEQ.S    @0
  90.     SUBI    #257,(PS)
  91.     @0:    RTS
  92.  
  93.     DC.B    6,'WHA'            ; "whazat" ( -- )
  94.     DC.W    QButton-theLink
  95. WhaZat:    jsr    dwrd-base(bp)        ; push token address
  96.     BRA.S    huh
  97.  
  98.     DC.B    5,'ABO'            ; "abort" ( -- )
  99.     DC.W    whazat-theLink
  100. huh:    MOVE.L    Szero-base(BP),PS    ; reset stack pointer < moved 5/93
  101.     MOVEQ    #63,D0            ; send ?
  102.     JSR    EmitCode-base(BP)
  103.     BSR.S    crlf
  104.     BRA.S    fin
  105.     
  106.     DC.B    4,'QUI'            ; "quit" ( -- )
  107.     DC.W    huh-theLink        ;    restart the interpreter loop
  108. fin:    JSR    emptyfs-base(BP)    ; clear pending loads
  109.     CLR.L    fcolon-base(BP)        ; clear compiling flag
  110.     BSET.B    #7,fint-base(BP)    ; reset to keyboard input
  111.     JMP    cret-base(BP)
  112.  
  113.     DC.B    2,'CR',0        ; "cr" ( -- ) output CR to screen
  114.     DC.W    fin-theLink
  115. CRLF:    JMP    doCR-Base(BP)        ; part of emit
  116.  
  117.     DC.B    3,'.OK'            ; ".ok" ( -- )
  118.     DC.W    crlf-theLink
  119. Prompt:    JSR    space-base(BP)        ; send space
  120.     MOVEQ    #111,D0
  121.     JSR    EmitCode-base(BP)    ; send "o"
  122.     MOVEQ    #107,D0
  123.     JSR    EmitCode-base(BP)    ; send "k"
  124.     JMP    space-base(BP)        ; send another space & return
  125.  
  126.     DC.B    5,'UPP'            ; "upper" ( addr -- )
  127.     DC.W    prompt-theLink        ;   change a string to upper case
  128. Upper:    MOVE    (PS)+,D0
  129.     LEA    0(BP,D0.W),A0        ; get the address
  130.     CLR    D0
  131.     MOVE.B    (A0),D0            ; get count
  132.     @0:    CMPI.B    #$60,0(A0,D0.W)        ; BEGIN  get char at addr + count
  133.     BLE.S    @1            ;   char > 'a'
  134.     CMPI.B    #$7B,0(A0,D0.W)        ;   char < 'z'
  135.     BGE.S    @1            ;   AND IF
  136.     SUBI.B    #32,0(A0,D0.W)        ;     char 32 - -> char THEN
  137.     @1:    DBRA    D0,@0            ; count 1- -> count count NOT UNTIL
  138.     RTS
  139.  
  140.     DC.B    5,'TOK'            ; "token" ( -- ) put a token
  141.     DC.W    upper-theLink        ;   from (IS) into (DP),
  142. Token:    MOVE    #32,-(PS)        ;   which is at end of dict.
  143.     BSR.S    word
  144.     JSR    here-base(BP)        ; Fri Apr 29, 1988 00:27:23 simpl
  145.     BRA.S    Upper
  146.  
  147.     DC.B    6,'HEA'            ; "header" ( -- ) create a header
  148.     DC.W    token-theLink        ;   for the current word at DP
  149. Header:    MOVE    Dict,4(DP)        ; link header to dictionary
  150.     MOVE.L    DP,Dict            ; update DICT
  151.     SUB.L    BP,Dict            ; make it a rel.addr
  152.     addq.l    #6,dp            ; update DP
  153.     RTS
  154.  
  155.     DC.Bvrefnum on stack        ***
  156.     CLR    D0
  157.     @0:    MOVE.L    10(A2,D0.W),40(A2,D0.W)    ; move the file name to PAD
  158.     ADDQ    #4,D0
  159.     CMP    #32,D0
  160.     BLE.S    @0
  161.     ADDQ    #1,openFlag-base(BP)
  162.     RTS
  163.  
  164.     DC.B    3,'-->'            ; "-->" ( -- )
  165.     DC.W    open-theLink
  166. Load:    JSR    token-base(BP)        ; put filename string at HERE
  167.     CLR    -(PS)            ; set vrefnum to 0 (path is specified)
  168.     BRA.S    load1
  169.     
  170. doLoad:
  171.     lea    40(a2),a0        ; Move the file name from PAD to HERE
  172.     move.l    a2,a1
  173.     moveq    #32,d0
  174.     _blockmove
  175.  
  176. ;    CLR    D0            ; Move the file name from PAD to HERE
  177. ;   @0:    MOVE.L    40(A2,D0.W),0(A2,D0.W)    ; 
  178. ;    ADDQ    #4,D0            ; 
  179. ;    CMP    #32,D0            ; 
  180. ;    BLE.S    @0
  181.  
  182.  load1:    MOVE    fsptr-base(BP),D0    ; get file stack pointer
  183.     BMI.S    @1            ;  ... save the offset into text ...
  184.     LEA    fofsets-base(BP),A0    ;  ... at fofsets+fspointer
  185.     MOVE.L    TextO-base(BP),0(A0,D0.W)
  186.     LEA    fends-base(BP),A0    ;  TextE at fends+fspointer
  187.     MOVE.L    TextE-base(BP),0(A0,D0.W)
  188.     @1:    ADDQ    #4,fsptr-base(BP)    ; increment the file stack pointer
  189.     
  190.     MOVE.L    #80,D0            ; create an 80 byte block for
  191.     _NewPtr.CLEAR            ; make the file control buffer
  192.     MOVE.L    A0,A4            ; save it for later
  193.     MOVE.B    #1,27(A0)        ; set read only permission
  194.     MOVE.L    DP,18(A0)        ; set name pointer
  195.     MOVE    (PS)+,22(A0)        ; set vrefnum (working directory)
  196.     _HOpen
  197.     TST    16(A0)
  198.     BNE.S    derror
  199.     _GetEOF                ; get ...
  200.     MOVE.L    28(A0),36(A0)        ;  ... and set ...
  201.     MOVE.L    28(A0),-(PS)        ;  ... and hold the file size
  202.     
  203.     MOVE.L    (PS),D0            ; set block size = file size
  204.     _NewHandle
  205.     BMI.S    derror
  206.     
  207.     MOVE    fsptr-base(BP),D0    ; get file stack pointer
  208.     LEA    fstack-base(BP),A1    ; file stack address
  209.     MOVE.L    A0,0(A1,D0.W)        ; stash the handle at fstack+(fsptr)
  210.     _HLock
  211.     
  212.     MOVE.L    (A0),A0            ; get start addr of block
  213.     MOVE.L    A0,TextO-base(BP)    ; set buffer start
  214.     MOVE.L    A0,D0            ; set buffer end ...
  215.     ADD.L    (PS)+,D0
  216.     MOVE.L    D0,TextE-base(BP)    ;  ... to start + size
  217.     
  218.     MOVE.L    A4,A0            ; retrieve fcb pointer
  219.     MOVE.L    TextO-base(BP),32(A0)    ; set read buffer addr in fcb
  220.     _Read                ; read data from file ...
  221.     TST    16(A0)            ; ... to scrap buffer
  222.     BNE.S    derror
  223.     _Close
  224.     _DisposPtr
  225.     JMP    go-base(BP)        ; interpret scrap buffer
  226.  
  227. DError:    MOVE    16(A0),-(PS)
  228.     _Close
  229.     _DisposPtr
  230.     JSR    pquote-base(BP)
  231.     DC.B    5,'Disk:'        ; print the error messsage
  232.    der:    JSR    dot-base(BP)        ; report the error number
  233.   der1:    JMP    huh-base(BP)
  234.  
  235. ;        DC.B    3,'REZ'        ; Return the handle to a resource
  236. ;        DC.W    load-theLink    ; ( ID type -- handle t or f )
  237. ;    Rez:    CLR.L    -(SP)
  238. ;        MOVE.L    (PS)+,-(SP)
  239. ;        MOVE    (PS)+,-(SP)
  240. ;        _GetResource
  241. ;        MOVE.L    (SP)+,D0    ; nil handle means error
  242. ;        BEQ.S    gser2
  243. ;        MOVE.L    D0,-(PS)
  244. ;        MOVE    #-1,-(PS)
  245. ;        RTS
  246.  
  247.     DC.B    8,'?GE'        ; "?GESTALT"
  248.     DC.W    load-theLink    ; ( d.selector -- d.response true or false )
  249. QGestalt:        ; false if 64K ROM or no _Gestalt or bad selector
  250.     ; check for 64K ROM
  251.     MOVE    #$A86E,D0        ; _InitGraf
  252.     _GetTrapAddress.newTool
  253.     MOVE.L    A0,D1
  254.     MOVE    #$AA6E,D0        ; _InitGraf AND $200
  255.     _GetTrapAddress.newTool
  256.     CMP.L    A0,D1
  257.     BEQ.S    gser1            ; 64KROM
  258.  
  259.     ; Check for gestalt
  260.     MOVE.W    #$A89F,D0        ; _Unimplemented
  261.     _GetTrapAddress.newTool        ; NGetTrapAddress
  262.     MOVE.L    A0,D1
  263.     MOVE.W    #$A1AD,D0        ; _Gestalt
  264.     _GetTrapAddress.newOS        ; NGetTrapAddress
  265.     CMP.L    A0,D1
  266.     BEQ.S    gser1            ; no gestalt
  267.  
  268.     ; run gestalt
  269.     MOVE.L    (PS)+,D0
  270.     _Gestalt
  271.     BNE.S    gser2
  272.     MOVE.L    A0,-(PS)        ; return the result  ... and ...
  273.     MOVE    #-1,-(PS)        ; return true
  274.  gsret:    RTS
  275.  
  276.  gser1:    ADDQ.L    #4,PS            ; gestalt error
  277.  gser2:    CLR    -(PS)            ; return false
  278.     RTS
  279.  
  280.     DC.B    128+2,',S',0        ; ",S" compile a dnumber from ascii
  281.     DC.W    qgestalt-theLink    ; NOTE: 1 and only 1 space seperates
  282. CommaS:    MOVE.L    A2,A0
  283.     MOVEQ    #4,D0
  284.     @0:    MOVE.B    (IS)+,(A0)+
  285.     DBRA    D0,@0
  286.     MOVE.L    (A2),-(PS)
  287.  
  288.     TST.B    fcolon-base(BP)
  289.     BEQ.S    gsret
  290.     JMP    dlit-base(BP)
  291.  
  292.     DC.B    64+9,'INT'        ; "interpret"
  293.     DC.W    commas-theLink
  294. Interp:    JMP    main-base(BP)
  295.     RTS            ; <- gotta have this for mcompile
  296.  
  297.     DC.B    4,'ROO'            ; "room" ( -- bytes )
  298.     DC.W    interp-theLink
  299. Room:    MOVE.L    A3,A0
  300.     _RecoverHandle            ; use handle rather than pointer
  301.     _GetHandleSize
  302.     MOVE.L    A3,A0            ; Bottom
  303.     ADDA.L    D0,A0            ;  +  block size ...
  304.     SUBA.L    A2,A0            ;  -  end of dictionary
  305.     MOVE    A0,-(PS)        ;  =  unused dictionary space
  306.     RTS
  307.  
  308. CSave:    CLR    -(SP)            ; Room for which item number.
  309.     MOVE    #259,-(SP)        ; Resource ID of ALRT
  310.     CLR.L    -(SP)
  311.     _Alert                ; About Item
  312.     SUBQ    #1,(SP)+        ; check which item dismissed.
  313.     BEQ.S    save            ; save if 'ok'
  314.     RTS
  315.  
  316.     DC.B    4,'SAV'            ; "save" ( -- ) save the dictionary
  317.     DC.W    room-theLink
  318. Save:    JSR    here-base(BP)
  319.     MOVE    (PS)+,freePt-base(BP)    ; save current DP
  320.     MOVE    Dict,DictPt-base(BP)    ; save current DictPt
  321.     BSR.S    room
  322.     MOVE    (PS),freesz-base(BP)    ; save current headroom
  323.     BSR.S    negate
  324.     BSR.S    grow            ; reduce headroom to 4 bytes
  325.     move.l    a3,A0            ; bottom
  326.     _RecoverHandle            ; get DICT's handle
  327.     CLR    -(SP)
  328.     MOVE.L    A0,-(SP)        ; push 2, 1 for each operation
  329.     MOVE.L    A0,-(SP)
  330.     _ChangedResource
  331.     _HomeResFile
  332.     _UpdateResFile            ; write out the DICT
  333.     MOVE    freesz-base(BP),-(PS)
  334. Grow:    JSR    here-base(BP)
  335.     MOVE    (PS)+,D1        ; hold rel DP in D1
  336.     MOVE.L    IS,-(PS)
  337.     JSR    torel-base(BP)
  338.     MOVE    (PS)+,D2
  339.     MOVE.L    (RS),-(PS)
  340.     JSR    torel-base(BP)
  341.     JSR    swapp-base(BP)
  342.     MOVEA.L    expand-base(BP),A0
  343.     JMP    (A0)            ; JSR won't return here
  344.  
  345.     DC.B    4,'>AB'            ; ">abs" (to-abs)
  346.     DC.W    save-theLink        ; ( addr16 -- daddr32 )
  347. toAbs:    CLR.L    D0
  348.     MOVE    (PS)+,D0        ; pop rel addr
  349.     LEA    0(BP,D0.W),A0        ; calc as offset to base ...
  350.     MOVE.L    A0,-(PS)        ; ...  and push
  351.     RTS
  352.  
  353.     DC.B    64+6,'NEG'        ; "negate" ( n -- -n )
  354.     DC.W    toabs-theLink
  355. negate:    NEG    (PS)
  356.     RTS
  357.  
  358.     DC.B    5,'SPA'            ; "space" ( -- ) emit a space
  359.     DC.W    negate-theLink
  360. space:    MOVE.L    #32,D0
  361.     bra.s    emitcode
  362.  
  363.     DC.B    4,'TYP'            ; "type" ( rel.addr len -- )
  364.     DC.W    space-theLink        ;  emit len characters from rel.addr
  365. Type:    MOVEM.L    D3/D4,-(SP)        ; don't trash registers!
  366.     MOVE    (PS)+,D3        ; get character count
  367.     SUBQ    #1,D3
  368.     MOVE    (PS)+,D4        ; get string relative address
  369.     @0:    MOVE.B    0(BP,D4.W),D0        ; get character byte
  370.     bsr.s    emitcode        ; print character byte
  371.     ADDQ    #1,D4
  372.     DBRA    D3,@0
  373.     MOVEM.L    (SP)+,D3/D4        ; restore registers
  374.     rts
  375.  
  376. pQuote:    ;   runtime part of ."
  377.     MOVE.L    (RS),-(PS)        ; push the addr of the string
  378.     JSR    torel-base(BP)
  379.     ADDQ    #1,(PS)            ; skip the length byte
  380.     MOVE.L    (RS),A0
  381.     CLR.L    D0            ; clear the character count
  382.     MOVE.B    (A0),D0            ; get the length
  383.     MOVE    D0,-(PS)        ; push it
  384.     ADDQ    #2,D0
  385.     ANDI    #$FFFE,D0        ; be sure its even
  386.     ADD.L    D0,(RS)            ; skip over string upon return
  387.     bra.s    type            ; type the string
  388.     
  389.     DC.B    4,'EMI'            ; "emit" ( n -- ) send the ascii
  390.     DC.W    type-theLink        ;                 to the terminal
  391. Emit:    MOVE    (PS)+,D0
  392.   EmitCode:                ; Emit contents of D0
  393.     CMP.B    #13,D0            ; is it a <cr>
  394.     BEQ.S    doCR
  395.     CMP.B    #8,D0            ; is it a <del>?
  396.     BEQ.S    doDEL
  397.     ANDI    #$FF,D0
  398.     MOVE    D0,-(A7)
  399.     _DrawChar
  400.     BSR.S    penh
  401.     MOVE    WContRect+6-base(BP),D0    ; right coord of WContRect
  402.     CMP    D0,D1            ; is the position beyond the edge
  403.     BLS.S    emitr            ; no
  404.     
  405.   doCR:    PEA    Scratch-base(BP)
  406.     _GetPen
  407.     MOVE    Scratch-base(BP),D1
  408.     MOVE    WContRect+4-base(BP),D0    ; bottom coord of WContRect
  409.     SUB    #11,D0
  410.     CMP    D0,D1            ; is the position below the window
  411.     BLS.S    @0            ; no
  412.  
  413.     ; yes it is below the bottom of the window, so scroll up 11 pixels
  414.     CLR.L    -(A7)            ; Make room for a region handle.
  415.     _NewRgn                ; get handle into (A7)
  416.     PEA    WContRect-base(BP)    ; rect to scroll
  417.     CLR    -(A7)            ; no horiz.
  418.     MOVE    #$FFF5,-(A7)        ; 11 pix. vert.
  419.     MOVE.L    8(A7),-(A7)        ; push the region handle
  420.     _ScrollRect
  421.     _DisposRgn
  422.  
  423.     MOVE    WContRect+4-base(BP),D1    ; bottom coord of WContRect
  424.     SUBQ    #4,D1
  425.     BRA.S    @1
  426.  
  427.     @0: ADD    #11,D1            ; Add line height to pen location
  428.     @1:    MOVE    #1,-(A7)
  429.     MOVE    D1,-(A7)
  430.     _MoveTo
  431.  emitr:    RTS
  432.  
  433.  doDEL:    BSR.S    penh
  434.     CMP    #6,D1            ; first column?
  435.     blt.s    @0            ; don't beep anymore
  436.     SUB    #6,D1            ; back up
  437.     MOVE    D1,-(SP)
  438.     MOVE    Scratch-base(BP),-(SP)
  439.     _MoveTo
  440.     @0:    RTS
  441.  
  442.   penh:    PEA    Scratch-base(BP)
  443.     _GetPen
  444.     MOVE    Scratch+2-base(BP),D1
  445.     RTS
  446.  
  447.     DC.B    6,'EXP'            ; "expect" ( addr count -- )
  448.     DC.W    emit-theLink
  449. Expect:    MOVEM.L    D4/IS,-(SP)
  450.     JSR    swapp-base(BP)        ; leave number of chars on stack
  451.     MOVE    (PS)+,D0        ; addr
  452.     LEA    0(BP,D0.W),IS        ; set IS to the input address
  453.     CLR    Counter
  454.     MOVE    (PS)+,D4
  455.     @0:    JSR    key-base(BP)
  456.     MOVE    (PS)+,D5
  457.     CMPI    #CR,D5            ; if key = CR
  458.     BNE.S    @1
  459.     MOVE.B    #BL,0(IS,Counter)
  460.     CLR.B    1(IS,Counter)
  461.     MOVE.B    #BL,2(IS,Counter)
  462.     BRA.S    @3
  463.     @1:    CMPI    #BS,D5            ; if key = backspace
  464.     BNE.S    @2
  465.     TST    Counter            ; do nothing if first key is BS
  466.     BEQ.S    @0
  467.     SUBQ    #1,Counter        ; decriment counter
  468.     bSR.s    dodel    ; -base(BP)
  469.     JSR    space-base(BP)        ;    ... rubout char
  470.     bSR.s    dodel    ; -base(BP)
  471.     BRA.S    @0
  472.     @2:    MOVE.B    D5,0(IS,Counter)    ; stash the key into input buffer
  473.     ADDQ    #1,Counter
  474.     MOVE    D5,D0
  475.     JSR    emitcode-base(BP)
  476.     CMP    D4,Counter        ; is count=number of chars to get?
  477.     BNE.S    @0
  478.     @3:    JSR    docr-base(BP)
  479.     MOVEM.L    (SP)+,D4/IS
  480.     RTS
  481.  
  482.     DC.B    64+1,'0',0,0        ; "0" ( -- 0 )
  483.     DC.W    expect-theLink
  484. Zero:    CLR    -(PS)
  485.     RTS
  486.     
  487.     DC.B    64+4,'DRO'        ; "drop" ( n -- )
  488.     DC.W    zero-theLink
  489. drop:    ADDQ.L    #2,PS
  490.     RTS
  491.  
  492.     DC.B    4,'SWA'            ; "swap" ( n1 n2 -- n2 n1 )
  493.     DC.W    drop-theLink
  494. swapp:    MOVE.L    (PS)+,D0
  495.     SWAP    D0
  496.     MOVE.L    D0,-(PS)
  497.     RTS
  498.  
  499.     DC.B    64+5,'2DR'        ; "2drop" ( d -- )
  500.     DC.W    swapp-theLink
  501. TwoDrop:
  502.     ADDQ.L    #4,PS
  503.     RTS
  504.  
  505.     DC.B    4,'NUL'            ; "null" ( -- )
  506.     DC.W    twodrop-theLink
  507. Null:    RTS
  508.  
  509.     dc.b    4,'WAR'            ; "warm" ( ? -- )
  510.     dc.w    null-theLink        ; added 6/1/93
  511. WarmSt:    jmp    warm-base(bp)
  512.     
  513.     DC.B    6,'FOR'            ; "forget" ( -- ) forgets dictionary
  514.     DC.W    warmst-theLink
  515. Forget:    JSR    tick-base(BP)
  516.     MOVE    (PS)+,D0
  517.     MOVE    -2(BP,D0.W),Dict
  518.     LEA    -6(BP,D0.W),DP
  519.     RTS
  520.  
  521.     DC.B    8,'CON'            ; "constant" compile: ( n16 -- )
  522.     DC.W    forget-theLink    ;            runtime: ( -- n16 )
  523. Const:    JSR    token-base(BP)        ; make a header for the next token
  524.     JSR    header-base(BP)
  525.     JSR    marco-base(BP)        ; to return a constant
  526.     JSR    literal-base(BP)    ; compile time comma, runtime push
  527.     MOVE    #$4E75,(DP)+        ; compile  rts 
  528.     RTS
  529.  
  530.     DC.B    6,'CRE'            ; "create" compile: ( -- ) 
  531.     DC.W    const-theLink        ;          runtime: ( -- addr16 )
  532. Create:    JSR    token-base(BP)        ; give token this runtime action:
  533.     JSR    header-base(BP)
  534.     MOVE    #$3D3C,(DP)+        ;  • move     #nnnn,-(ps)
  535.     JSR    here-base(BP)
  536.     ADDQ    #6,(PS)
  537.     MOVE    (PS)+,(DP)+        ; supply the nnnn from above
  538.     MOVE    #$4EEB,(DP)+        ;  • jmp     null-base(bp)
  539.     MOVE.L    DP,DoesAddr-base(BP)    ; set DoesAddr to this "null"
  540.     MOVE    #null-base,(DP)+
  541.     RTS
  542.  
  543.     DC.B    5,'DOE'            ; "does>" ( -- ) (use after create)
  544.     DC.W    create-theLink        ;   set runtime action 
  545. Does:    MOVE.L    (RS)+,D0        ; pop the return address
  546.     SUB.L    BP,D0            ; convert to rel.addr
  547.     MOVE.L    DoesAddr-base(BP),A0    ; load jmp d(bp) address from create
  548.     MOVE    D0,(A0)            ; and stash rel.addr into it
  549.     RTS                ; returns same as ;
  550.  
  551.     DC.B    5,'ALL'            ; "allot" ( n16 -- )
  552.     DC.W    does-theLink        ;  compiles nada into the dictionary
  553. Allot:    ADDQ    #1,(PS)
  554.     ANDI    #$FFFE,(PS)        ; make it even!
  555.     ADDA    (PS)+,DP        ; increment the dictionary pointer
  556.     RTS
  557.  
  558.     DC.B    8,'VAR'            ; "variable" compile: ( -- )
  559.     DC.W    allot-theLink        ;            runtime: ( -- addr16 )
  560. Variable:
  561.     JSR    token-base(BP)        ; give token this runtime action:
  562.     JSR    header-base(BP)
  563.     JSR    marco-base(BP)        ; Sun May 1, 1988 04:24:44
  564.     MOVE    #$3D3C,(DP)+        ;  • move   #nnnn,-(ps)
  565.     JSR    here-base(BP)
  566.     ADDQ    #4,(PS)            ;    calculate nnnn
  567.     MOVE    (PS)+,(DP)+        ;  • (this is the nnnn)
  568.     MOVE    #$4E75,(DP)+        ;  • rts
  569.     ADDQ.L    #2,DP            ; 2 allot
  570.     RTS
  571.  
  572.     DC.B    3,'AE:'
  573.     DC.W    variable-theLink
  574. aColon:    MOVE    #AEvents-base,-(PS)
  575.     @0:    JSR    at-base(BP)
  576.     ADDI    #10,(PS)
  577.     MOVE    (PS),-(PS)
  578.     JSR    at-base(BP)
  579.     TST    (PS)+
  580.     BNE.S    @0
  581.     MOVE    (PS)+,D1
  582.     MOVE.L    A2,D0
  583.     SUB.L    BP,D0
  584.     MOVE    D0,0(BP,D1.W)
  585.     MOVE.L    (PS)+,(A2)+
  586.     MOVE.L    (PS)+,(A2)+
  587.     LEA    4(A2),A0
  588.     SUBA.L    A3,A0
  589.     MOVE    A0,(A2)+
  590.     CLR    (A2)+
  591.     MOVE    #$4EBA,(A2)+
  592.     MOVE    #aepre-base,-(PS)
  593.     JSR    back-base(BP)
  594.     JMP    rbrack-base(BP)
  595.  
  596.     DC.B    128+3,';AE'
  597.     DC.W    acolon-theLink
  598. semiae:    MOVE    #$4EAB,(A2)+        ; • jsr aepost(bp)
  599.     MOVE    #aepost-base,(A2)+    ; • rts
  600.     JMP    semi-base(BP)
  601.  
  602.     DC.B    64+5,'>NA'        ; ">name" ( 'addr -- name.addr )
  603.     DC.W    semiae-theLink
  604. toname:    SUBQ    #6,(PS)
  605.     RTS
  606.     
  607.     DC.B    64+5,'>LI'        ; ">link" ( 'addr -- link.addr )
  608.     DC.W    toname-theLink
  609. tolink:    SUBQ    #2,(PS)
  610.     RTS
  611.  
  612.     DC.B    3,'ID.'            ; "id." ( addr -- )
  613.     DC.W    tolink-theLink
  614. IDDot:    JSR    toname-base(BP)
  615.     MOVEA.L    DP,A0
  616.     MOVEQ.L    #5,D0
  617.     @0:    MOVE.L    #$C9C9C9C9,(A0)+    
  618.     DBRA    D0,@0
  619.     MOVE    (PS)+,D0
  620.     MOVE.L    0(BP,D0.W),(DP)
  621.     JSR    here-base(BP)
  622.     MOVE    (PS),-(PS)
  623.     JSR    cat-base(BP)
  624.     ANDI    #$1F,(PS)        ; look at 5 lsb's
  625.     ADDQ    #1,2(PS)
  626.     JSR    type-base(BP)
  627.     JMP    space-base(BP)
  628.     
  629.     DC.B    5,'WOR'            ; "words" ( -- ) list words
  630.     DC.W    iddot-theLink
  631. Words:    MOVE.L    D3,-(SP)        ; preserve register
  632.     MOVE    Dict,D3            ; start with the last word defined
  633.     @0:    MOVE    D3,-(PS)        ; push the name address
  634.     ADDQ    #6,(PS)            ; get the CFA
  635.     BSR.S    iddot            ; print the name
  636.      MOVE    4(BP,D3.W),D3        ; put the next name addr into D3
  637.     TST.B    1(BP,D3.W)        ; Quit if name is 0
  638.     BEQ.S    @1            ; do next word if not=0
  639.     JSR    qterm-base(BP)
  640.         TST    (PS)+
  641.     BEQ.S    @0
  642.     @1:    MOVE.L    (SP)+,D3        ; restore register
  643.     RTS
  644.     
  645.     DC.B    3,'PAD'            ; "pad" ( -- ) conversion pad
  646.     DC.W    words-theLink
  647. Pad:    JSR    here-base(BP)
  648.     ADDI    #40,(PS)        ; pad is 40 bytes from HERE.
  649.     RTS
  650.     
  651.     DC.B    4,'HOL'            ; "hold" ( c -- ) place c at ...
  652.     DC.W    pad-theLink        ; ... addr in Held.
  653. Hold:    SUBQ    #1,held-base(BP)
  654.     MOVE    held-base(BP),-(PS)
  655.     JMP    cstore-base(BP)
  656.     
  657.     DC.B    4,'SIG'            ; "sign" ( sf dval -- dval )
  658.     DC.W    hold-theLink
  659. Sign:    JSR    rote-base(BP)
  660.     TST    (PS)+
  661.     BGE.S    @0
  662.     MOVE    #'-',-(PS)
  663.     BSR.S    hold
  664.     @0:    RTS
  665.  
  666.     DC.B    4,'DAB'            ; "dabs" ( dval -- |dval| )
  667.     DC.W    sign-theLink
  668. Dabs:    TST    (PS)
  669.     BGE.S    @0
  670.     JSR    dneg-base(BP)
  671.     @0:    RTS
  672.  
  673.     DC.B    2,'<#',0        ; "<#" ( -- )
  674.     DC.W    dabs-theLink
  675. LSharp:    BSR.S    pad
  676.     MOVE    (PS)+,held-base(BP)
  677.     MOVEA.L    DP,A0
  678.     MOVE    #9,D0
  679.     @0:    CLR.L    (A0)+
  680.     DBRA    D0,@0
  681.     MOVE    #30,-(PS)
  682.     BRA.S    hold
  683.  
  684.     DC.B    2,'#>'.0        ; "#>" ( dval -- addr len )
  685.     DC.W    lsharp-theLink
  686. SharpG:    ADDQ.L    #2,PS
  687.     MOVE    held-base(BP),(PS)
  688.     BSR.S    pad
  689.     MOVE    2(PS),-(PS)        ; over
  690.     ADDQ    #1,(PS)
  691.     JMP    minus-base(BP)
  692.     
  693.     DC.B    1,'#',0,0        ; "#" ( dval -- d/base )
  694.     DC.W    sharpg-theLink
  695. Sharp:    MOVE    NBase-base(BP),-(PS)
  696.     JSR    msmod-base(BP)
  697.     JSR    rote-base(BP)
  698.     CMPI    #9,(PS)            ; is top of stack < 9?
  699.     BLE.S    @0
  700.     ADDQ    #7,(PS)
  701.     @0:    ADDI    #48,(PS)
  702.     JMP    hold-base(BP)
  703.  
  704.     DC.B    2,'#S',0        ; "#s" ( dval -- 0 0 )
  705.     DC.W    sharp-theLink
  706. Sharps:    BSR.S    sharp
  707.     TST.L    (PS)
  708.     BNE.S    sharps
  709.     RTS
  710.  
  711.     DC.B    2,'D.',0        ; "d." ( dval -- )
  712.     DC.W    sharps-theLink
  713. DDot:    JSR    swapp-base(BP)
  714.     MOVE    2(PS),-(PS)
  715.     JSR    dabs-base(BP)
  716.     BSR.S    lsharp
  717.     BSR.S    sharps
  718.     JSR    sign-base(BP)
  719.     BSR.S    sharpg
  720.     jsr    type-base(BP)
  721.     jmp    space-base(bp)
  722.  
  723.     DC.B    2,'U.',0        ; "u." ( uval -- )
  724.     DC.W    ddot-theLink
  725. UDot:    CLR    -(PS)
  726.     BRA.S    ddot
  727.  
  728.     DC.B    3,'S>D'            ; "s>d" ( n -- d )
  729.     DC.W    udot-theLink
  730. SToD:    MOVE    (PS),-(PS)        ; dup
  731.     JMP    zerolt-base(BP)        ; 0<
  732.  
  733.     DC.B    1,'.',0,0        ; "." ( n -- )
  734.     DC.W    stod-theLink
  735. Dot:    BSR.S    stod
  736.     BRA.S    ddot
  737.  
  738.     DC.B    130,'."',0        ; "."" ( -- ) compiler part of (.")
  739.     DC.W    dot-theLink
  740. dotQ:    MOVE    #pQuote-base,-(PS)
  741.     JSR    compile-base(BP)    ; compile a call to (.")
  742.     JSR    here-base(BP)        ; ( -- addr )
  743.     MOVE    #'"',-(PS)        ; ( -- addr 34 )
  744.     JSR    word-base(BP)        ; ( -- addr )
  745.     JSR    cat-base(BP)        ; ( -- count )
  746.     ADDQ    #1,(PS)            ; ( -- count+1 )
  747.     JMP    allot-base(BP)        ; enclose the string in dictionary
  748.     
  749.     DC.B    129,'(',0,0        ; "(" ( -- ) begin comment
  750.     DC.W    dotq-theLink
  751. Comment    CMPI.B    #41,(IS)+        ; read in characters until ")"
  752.     BNE.S    Comment
  753.     RTS
  754.  
  755.     DC.B    5,'CMO'            ; "cmove" ( addr1 addr2 len -- )
  756.     DC.W    comment-theLink        ; from figFORTH, fixed 8/3/91
  757. CMove:    MOVE    (PS)+,D0        ; D0 = length
  758.     MOVE    (PS)+,D1
  759.     LEA    0(BP,D1.W),A1        ; A1 = addr2
  760.     MOVE    (PS)+,D1
  761.     LEA    0(BP,D1.W),A0        ; A0 = addr1
  762.     CMPA.L    A0,A1
  763.     BPL.S    @2
  764.  
  765.     BRA.S    @1            ;  addr1 > addr2
  766.     @0:    MOVE.B    (A0)+,(A1)+
  767.     @1:    DBRA    D0,@0
  768.     RTS
  769.  
  770.     @2:    ADDA    D0,A0            ;  addr1 ≤ addr2
  771.     ADDA    D0,A1
  772.     BRA.S    @4
  773.     @3:    MOVE.B    -(A0),-(A1)
  774.     @4:    DBRA    D0,@3
  775.     RTS
  776.     
  777.     DC.B    4,'FIL'            ; "fill" ( addr count char -- )
  778.     DC.W    cmove-theLink
  779. Fill:    MOVE    (PS)+,D0        ; character
  780.     MOVE    (PS)+,D1        ; count
  781.     SUBQ    #1,D1            ; decrement count
  782.     MOVE    (PS)+,A0        ; relative addr
  783.     LEA    0(BP,A0.W),A0        ; get absolute addr
  784.     @0:    MOVE.B    D0,0(A0,D1.W)        ; put char into addr + count
  785.         DBRA    D1,@0            ; decrement count & loop until 0
  786.     RTS
  787.     
  788.     DC.B    9,'-TR'            ; "-trailing"
  789.     DC.W    fill-theLink        ;  ( addr count -- addr new.count )
  790. dtrail:    MOVE    (PS)+,D1        ; get the count
  791.     MOVE    (PS),D0            ; get the rel.addr
  792.     LEA    0(BP,D0.W),A0        ; get the abs.addr
  793.     @0:    CMPI.B    #$20,-1(A0,D1.W)    ; BEGIN  is char at addr+count $20
  794.     DBNE    D1,@0            ; NOT UNTIL
  795.     MOVE    D1,-(PS)        ; put new count on stack
  796.     RTS
  797.     
  798.     DC.B    64+2,'1+',0        ; "1+" ( n -- n+1 )
  799.     DC.W    dtrail-theLink
  800. OnePl:    ADDQ    #1,(PS)
  801.     RTS
  802.  
  803.     DC.B    64+2,'1-',0        ; "1-" ( n -- n-1 )
  804.     DC.W    onepl-theLink
  805. OneMi:    SUBQ    #1,(PS)
  806.     RTS
  807.     
  808.     DC.B    64+2,'2+',0        ; "2+" ( n -- n+2 )
  809.     DC.W    onemi-theLink
  810. TwoPl:    ADDQ    #2,(PS)
  811.     RTS
  812.     
  813.     DC.B    64+2,'2*',0        ; "2*" ( n -- n*2 )
  814.     DC.W    twopl-theLink
  815. ToStar:    ASL    (PS)
  816.     RTS
  817.  
  818.     DC.B    64+2,'2/',0        ; "2/" ( n -- n/2 )
  819.     DC.W    tostar-theLink
  820. ToDiv:    ASR    (PS)
  821.     RTS
  822.     
  823.     DC.B    5,'DEP'            ; "depth" ( -- n )
  824.     DC.W    )+,D0
  825.     BNE.S    @0
  826.     BRA.S    sfail
  827.     @0:    MOVE    (PS)+,D1
  828.     EXT.L    D1
  829.     DIVS    D0,D1
  830.     SWAP    D1
  831.     MOVE.L    D1,-(PS)
  832.     RTS
  833.  
  834.     DC.B    1,'/',0,0        ; "/" ( n1 n2 -- quotient )
  835.     DC.W    smod-theLink
  836. Slash:    bsr.s    smod
  837.     JSR    swapp-base(BP)
  838.     ADDQ.L    #2,PS
  839.     RTS
  840.  
  841.     DC.B    3,'MOD'            ; "mod"    ( n1 n2 -- remainder )
  842.     DC.W    slash-theLink
  843. mod:    bsr.s    smod
  844.     ADDQ.L    #2,PS
  845.     RTS
  846.  
  847.     DC.B    2,'*/',0        ; "*/" ( n1 n2 n3 -- n1*n2/n3 )
  848.     DC.W    mod-theLink
  849. SSlash:    MOVE    (PS)+,D1
  850.     BNE.S    sok
  851.     ADDQ.L    #2,PS
  852.  sfail:    MOVE    #-1,(PS)
  853.     RTS
  854.    sok:    MOVE    (PS)+,D0
  855.     MULS    (PS),D0
  856.     DIVS    D1,D0
  857.     MOVE    D0,(PS)
  858.     RTS
  859.  
  860.     DC.B    2,'U*',0        ; "u*" ( n1 n2 -- d32 )
  861.     DC.W    sslash-theLink
  862. UStar:    MOVE    (PS)+,D0
  863.     MULU    (PS)+,D0
  864.     MOVE.L    D0,-(PS)
  865.     RTS
  866.     
  867.     DC.B    5,'M/M'            ; "m/mod" from King&Knight
  868.     DC.W    ustar-theLink        ; ( num32 denom16 -- rem16 quot32 )
  869. MSMod:    TST    (PS)            ; test for div by zero
  870.     BNE.S    @0
  871.     ADDQ.L    #4,PS
  872.     BRA.S    sfail
  873.     @0:    MOVE.L    D2,-(SP)        ; save D2
  874.     MOVEQ    #0,D2            ; clear it
  875.     MOVE    (PS)+,D2        ; pop denom into D2.W
  876.     MOVE.L    (PS)+,D1        ; pop num into D1.L
  877.     MOVE    D1,-(SP)        ; hold num.l on rstack
  878.     CLR    D1
  879.     SWAP    D1
  880.     DIVU    D2,D1
  881.     MOVE    D1,D0
  882.     MOVE    (SP)+,D1
  883.     DIVU    D2,D1
  884.     SWAP    D1
  885.     MOVE    D1,-(PS)        ; push remainder
  886.     MOVE    D0,D1
  887.     SWAP    D1
  888.     MOVE.L    D1,-(PS)        ; push quotient
  889.     MOVE.L    (SP)+,D2        ; restore register
  890.     RTS
  891.     
  892.     DC.B    64+7,'DNE'        ; "dnegate" ( d32 -- -d32 )
  893.     DC.W    msmod-theLink
  894. DNeg:    NEG.L    (PS)
  895.     RTS
  896.     
  897.     DC.B    64+2,'D+',0        ; "d+" ( d1 d2 -- d1+d2 )
  898.     DC.W    dneg-theLink
  899. DPlus:    MOVE.L    (PS)+,D0
  900.     ADD.L    D0,(PS)
  901.     RTS
  902.     
  903.     DC.B    128+2,'IF',0        ; "if" ( flag -- ) at runtime
  904.     DC.W    dplus-theLink        ;      ( -- addr ) at compile time
  905. pIf:    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  906.   pi1:    bsr.s    pbegin
  907.     ADDQ.L    #2,DP            ; make room for offset
  908.     RTS
  909.     
  910.     DC.B    128+5,'WHI'        ; "while" ( flag -- ) at runtime
  911.     DC.W    pif-theLink        ;    ( -- addr ) at compile time
  912. pWhile:    BRA.S    pIf
  913.     
  914.     DC.B    128+4,'ELS'        ; "else" ( -- ) at runtime
  915.     DC.W    pwhile-theLink        ; ( addr -- addr ) at compile time
  916. pElse:    MOVE    #$6000,(DP)+
  917.     bsr.s    pi1
  918.     JSR    swapp-base(BP)
  919.     BRA.S    pthen
  920.  
  921.     DC.B    128+4,'THE'        ; "then" ( -- ) at runtime
  922.     DC.W    pelse-theLink        ;   ( addr -- ) at compile time
  923. pThen:    bsr.s    pbegin
  924.     MOVE    2(PS),-(PS)        ; over
  925.     JSR    minus-base(BP)
  926.     JSR    swapp-base(BP)
  927.     JMP    store-base(BP)
  928.  
  929.     DC.B    128+6,'REP'        ; "repeat" ( -- ) at runtime
  930.     DC.W    pthen-theLink        ; ( b.addr w.addr -- ) at c.time
  931. pRepet:    MOVE    #$6000,(DP)+        ; compile bra ...
  932.     JSR    swapp-base(BP)
  933.     BSR.S    back
  934.     BRA.S    pThen            ; HERE OVER - SWAP ! ;
  935.  
  936.     DC.B    128+5,'BEG'        ; "begin" ( -- ) at runtime
  937.     DC.W    prepet-theLink        ;    ( -- addr ) at compile time
  938. pBegin:    JMP    here-base(BP)
  939.  
  940.     DC.B    128+5,'UNT'        ; "until" ( flag -- ) at runtime
  941.     DC.W    pbegin-theLink        ;      ( addr -- ) at compile time
  942. pUntil    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  943.     BRA.S    back
  944.     
  945.     DC.B    128+5,'AGA'        ; "again" ( -- ) at runtime
  946.     DC.W    puntil-theLink        ;    ( addr -- ) at compile time
  947. pAgain:    MOVE    #$6000,(DP)+        ; compile bra ...
  948.     BRA.S    back
  949.  
  950.     DC.B    4,'BAC'            ; "back" ( addr -- )
  951.     DC.W    pagain-theLink        ;  compile negative displacement
  952. back:    bsr.s    pbegin
  953.     JSR    minus-base(BP)
  954.     MOVE    (PS),D0            ; get the target addr into d0
  955.     BGE.S    @0
  956.     NEG    D0            ; make it positive
  957.     @0:    ANDI    #$FF80,D0        ; if > 1 byte
  958.     BEQ.S    @1
  959.     JMP    comma-base(BP)        ; then comma it as a long branch
  960.     @1:    MOVE.B    1(PS),-1(DP)        ; else make it a short branch
  961.     JMP    drop-base(BP)
  962.  
  963.     DC.B    128+2,'DO',0        ; "do" ( -- addr ) at compile time
  964.     DC.W    back-theLink        ;  ( limit index -- ) at runtime
  965. do:    MOVE    #$2F1E,(DP)+        ; • move.l (ps)+,-(ps)
  966.     bra.s    pbegin
  967.     
  968.     DC.B    128+4,'LOO'        ; "loop" ( -- ) at runtime
  969.     DC.W    do-theLink        ;   ( addr -- ) at compile time
  970. Loop:    MOVE.L    #$52573017,(DP)+    ;  • addq #1,(rs)  (increment ix)
  971.     MOVE.L    #$B06F0002,(DP)+    ;  • move (rs),d0  (get ix)
  972.     MOVE    #$6B00,(DP)+        ;  • cmp  2(rs),d0 (check lim)
  973.   pl:    BSR.S    back            ;  • bmi  ...      (loop if ix<lim)
  974.     MOVE    #$588F,(DP)+        ; comma in the displacement to 'do'
  975.     RTS                ;  • addq.l #4,rs    (drop ix&lim)
  976.     
  977.     DC.B    128+5,'+LO'        ; "+loop" ( n -- ) at runtime
  978.     DC.W    loop-theLink        ;   ( addr -- ) at compile time
  979. pLoop:    MOVE    #$4EAB,(DP)+
  980.     MOVE    #ppl-base,(DP)+        ;  • jsr ppl-base(bp)
  981.     MOVE    #$6700,(DP)+        ;  • beq  ...  (neg flag change)
  982.     BRA.S    pl
  983.  
  984. ppl:    MOVE    4(A7),D0        ; get index
  985.     CMP    6(A7),D0        ; check limit
  986.     MOVE    SR,D1            ; hold result
  987.     MOVE     (PS)+,D0        ; get step 
  988.     ADD    D0,4(A7)        ; incerment index
  989.     MOVE    4(A7),D0        ; get new index
  990.     CMP    6(A7),D0        ; check new limit
  991.     MOVE    SR,D0            ; hold it
  992.     EOR    D0,D1            ; mix with last result
  993.     AND    #8,D1            ; check for change in neg flag
  994.     RTS
  995.     
  996.     DC.B    5,'LEA'            ; "leave" ( -- )
  997.     DC.W    ploop-theLink        ;  set the index to the limit
  998. Leave:    MOVE    6(RS),4(RS)
  999.     RTS
  1000.  
  1001.     DC.B    2,'0<',0        ; "0<" ( n -- flag )
  1002.     DC.W    leave-theLink
  1003. ZeroLT:    TST    (PS)
  1004.     BLT.S    true
  1005.  false:    CLR    (PS)
  1006.     RTS
  1007.  true:    MOVE    #-1,(PS)
  1008.     RTS
  1009.  
  1010.     DC.B    2,'0>',0        ; "0>" ( n -- flag )
  1011.     DC.W    zerolt-theLink
  1012. ZeroGT:    NEG    (PS)
  1013.     BRA.S    zerolt
  1014.  
  1015.     DC.B    2,'0=',0        ; "0=" ( n -- flag )
  1016.     DC.W    zerogt-theLink
  1017. ZeroEQ:    TST    (PS)
  1018.     BEQ.S    true
  1019.     BRA.S    false
  1020.  
  1021.     DC.B    64+1,'+',0,0        ; "+" ( n1 n2 -- n1+n2 )
  1022.     DC.W    zeroeq-theLink
  1023. plus:    MOVE    (PS)+,D0
  1024.     ADD    D0,(PS)
  1025.     RTS
  1026.  
  1027.     DC.B    1,'-',0,0        ; "-" ( n1 n2 -- n1-n2 )
  1028.     DC.W    plus-theLink
  1029. minus:    NEG    (PS)
  1030.     bra.s    plus
  1031.  
  1032.     DC.B    1,'=',0,0        ; "=" ( n1 n2 -- flag )
  1033.     DC.W    minus-theLink
  1034. equal:    bsr.s    minus
  1035.     BRA.S    zeroeq
  1036.  
  1037.     DC.B    1,'<',0,0        ; "<" ( n1 n2 -- flag )
  1038.     DC.W    equal-theLink
  1039. lesst:    bsr.s    minus
  1040.     BRA.S    zerolt
  1041.  
  1042.     DC.B    1,'>',0,0        ; ">" ( n1 n2 -- flag )
  1043.     DC.W    lesst-theLink
  1044. moret:    bsr.s    minus
  1045.     BRA.S    zerogt
  1046.  
  1047.     DC.B    64+3,'AND'        ; "and"    ( n1 n2 -- n1(and)n2 )
  1048.     DC.W    moret-theLink
  1049. andd:    MOVE    (PS)+,D0
  1050.     AND    D0,(PS)
  1051.     RTS
  1052.  
  1053.     DC.B    64+2,'OR',0        ; "or" ( n1 n2 -- n1(or)n2 )
  1054.     DC.W    andd-theLink
  1055. orr:    MOVE    (PS)+,D0
  1056.     OR    D0,(PS)
  1057.     RTS
  1058.     
  1059.     DC.B    64+3,'XOR'        ; "xor" ( n1 n2 -- n1(xor)n2 )
  1060.     DC.W    orr-theLink
  1061. xor:    MOVE    (PS)+,D0
  1062.     EOR    D0,(PS)
  1063.     RTS
  1064.  
  1065.     DC.B    3,'ABS'            ; "abs"    ( n1 -- abs(n1) )
  1066.     DC.W    xor-theLink
  1067. abs:    TST    (PS)
  1068.     BGE.S    @0
  1069.     NEG    (PS)
  1070.     @0:    RTS
  1071.  
  1072.         DC.B    3,'MIN'            ; "min" ( n1 n2 -- n(min) )
  1073.     DC.W    abs-theLink
  1074. min:    MOVE    (PS)+,D0
  1075.     CMP    (PS),D0
  1076.     BLT.S    pd0
  1077.     RTS
  1078.    pd0:    MOVE    D0,(PS)
  1079.     RTS
  1080.  
  1081.         DC.B    3,'MAX'            ; "max" ( n1 n2 -- n(max) )
  1082.     DC.W    min-theLink
  1083. max:    MOVE    (PS)+,D0
  1084.     CMP    (PS),D0
  1085.     BGE.S    pd0
  1086.     RTS
  1087.  
  1088.     DC.B    2,'2@',0        ; "2@" ( addr -- d )
  1089.     DC.W    max-theLink        ; 32 bit fetch
  1090. TwoAt:    MOVE    (PS)+,D0
  1091.     MOVE.L    0(BP,D0.W),-(PS)
  1092.     RTS
  1093.  
  1094.     DC.B    2,'2!',0        ; "2!" ( d addr -- )
  1095.     DC.W    twoat-theLink        ; 32 bit store
  1096. TwoStore:
  1097.     MOVE    (PS)+,D0
  1098.     MOVE.L    (PS)+,0(BP,D0.W)
  1099.     RTS
  1100.  
  1101.     DC.B    9,'2CO'            ; "2constant"
  1102.     DC.W    twostore-theLink    ; defining: ( d -- )
  1103. TwoCon:    JSR    token-base(BP)        ; executing: ( -- d )
  1104.     JSR    header-base(BP)
  1105.     JSR    dlit-base(BP)
  1106.     MOVE    #$4E75,(DP)+
  1107.     RTS
  1108.  
  1109.     DC.B    9,'2VA'            ; "2variable"
  1110.     DC.W    twocon-theLink        ; defining: ( -- )
  1111. TwoVar:    JSR    variable-base(BP)    ; executing: ( -- addr )
  1112.     ADDQ.L    #2,DP
  1113.     RTS
  1114.  
  1115.     DC.B    64+3,'2>R'        ; "2>r" ( d -- ) rstack: ( -- d )
  1116.     DC.W    twovar-theLink
  1117. TwoToR:    MOVE.L    (PS)+,-(RS)
  1118.     RTS
  1119.  
  1120.     DC.B    64+3,'2R>'        ; "2r>" ( -- d ) rstack: ( d -- )
  1121.     DC.W    twotor-theLink
  1122. TwoRFrom:
  1123.     MOVE.L    (RS)+,-(PS)
  1124.     RTS
  1125.     
  1126.     DC.B    3,'A>R'            ; "a>r" ( addr -- )
  1127.     DC.W    tworfrom-theLink    ;   rstack: ( -- dabs.addr )
  1128. AToR:    JSR    toabs-base(BP)
  1129.     MOVE.L    (SP)+,A0
  1130.     MOVE.L    (PS)+,-(SP)
  1131.     JMP    (A0)
  1132.  
  1133.     DC.B    64+5,'2OV'        ; "2over" ( d1 d2 -- d1 d2 d1 )
  1134.     DC.W    ator-theLink
  1135. TwoOver:
  1136.     MOVE.L    4(PS),-(PS)
  1137.     RTS
  1138.  
  1139.     DC.B    4,'2RO'            ; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
  1140.     DC.W    twoover-theLink
  1141. TwoRot:    MOVE.L    (PS)+,D0
  1142.     MOVE.L    (PS)+,D1
  1143.     MOVE.L    (PS),A0
  1144.     MOVE.L    D1,(PS)
  1145.     MOVE.L    D0,-(PS)
  1146.     MOVE.L    A0,-(PS)
  1147.     RTS
  1148.  
  1149. ; floating point stack manipulation
  1150.     DC.B    64+5,'FDR'        ; FDROP ( n1 n2 n3 n4 n5 -- )
  1151.     DC.W    tworot-theLink
  1152. fdrop:    ADDQ.L    #6,PS
  1153.     ADDQ.L    #4,PS
  1154.     RTS
  1155.  
  1156.     DC.B    4,'FDU'        ; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1  n5 n4 n3 n2 n1 )
  1157.     DC.W    fdrop-theLink
  1158. fdup:    LEA    10(PS),A0
  1159.     MOVE.L    -(A0),-(PS)
  1160.     MOVE.L    -(A0),-(PS)
  1161.     MOVE.W    -(A0),-(PS)
  1162.     RTS
  1163.  
  1164.     DC.B    5,'FSW'            ; FSWAP ( f1 f2 -- f2 f1 )
  1165.     DC.W    fdup-theLink
  1166. fswap:    LEA    (PS),A0
  1167.     LEA    10(PS),A1
  1168.     MOVEQ    #4,D1
  1169.     @0:    MOVE    (A1),D0
  1170.     MOVE    (A0),(A1)+
  1171.     MOVE    D0,(A0)+
  1172.     DBRA    D1,@0
  1173.     RTS
  1174.  
  1175.     DC.B    5,'FPI'            ; FPICK ( fn..f1 m|n≥m≥1 -- fn..f1 fm )
  1176.     DC.W    fswap-theLink
  1177. fpick:    MOVE    #$0A,-(PS)
  1178.     JSR    times-base(BP)
  1179.     MOVE    (PS)+,D0
  1180.     LEA    0(PS,D0.W),A0
  1181.     MOVE.L    -(A0),-(PS)
  1182.     MOVE.L    -(A0),-(PS)
  1183.     MOVE    -(A0),-(PS)
  1184.     RTS
  1185.  
  1186.     DC.B    5,'FPA'        ; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew )
  1187.     DC.W    fpick-theLink
  1188. fpack:    MOVE    #$0A,-(PS)
  1189.     JSR    times-base(BP)
  1190.     MOVE    (PS)+,D0
  1191.     LEA    0(PS,D0.W),A0
  1192.     MOVE.L    (PS)+,(A0)+
  1193.     MOVE.L    (PS)+,(A0)+
  1194.     MOVE    (PS)+,(A0)+
  1195.     Rry
  1196. DictEnd:
  1197.